unit unitMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Buttons, ExtCtrls, AppEvnts;

type
  TfrmMain = class(TForm)
    lbledtWindowCaption: TLabeledEdit;
    lbledtWindowClass: TLabeledEdit;
    lbledtSearchString: TLabeledEdit;
    chkIsUnicode: TCheckBox;
    btnGetWindow: TBitBtn;
    btnSearch: TBitBtn;
    grpOptions: TGroupBox;
    mmoLog: TMemo;
    appEvs: TApplicationEvents;
    chkIsMask: TCheckBox;
    procedure btnGetWindowClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure appEvsIdle(Sender: TObject; var Done: Boolean);
    procedure btnSearchClick(Sender: TObject);
  private
    { Private declarations }
    FWnd: HWND;
    FProcess, FThread: Cardinal;
    FProcessHandle: THandle;
    FAnsiString: AnsiString;
    FWideString, FWideSerial: WideString;
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.dfm}

function EnabledDebugPrivilege(const Enabled: Boolean): Boolean;
var
  hTk: THandle;
  rtnTemp: Dword;
  TokenPri: TOKEN_PRIVILEGES;
const
  SE_DEBUG = 'SeDebugPrivilege';
begin
  Result := False;
  if (OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES, hTk)) then
  begin
    TokenPri.PrivilegeCount := 1;
    LookupPrivilegeValue(nil, SE_DEBUG, TokenPri.Privileges[0].Luid);
 
    if Enabled then
      TokenPri.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED
    else
      TokenPri.Privileges[0].Attributes := 0;
    rtnTemp := 0;
    AdjustTokenPrivileges(hTk, False, TokenPri, sizeof(TokenPri), nil, rtnTemp);
    Result := GetLastError = ERROR_SUCCESS;
    CloseHandle(hTk);
  end;
end;

{*
  ByteSearch AnsiString version;
*}
function ByteSearchA(Key, Buffer: PAnsiChar;
  KeyLen, BufferLen: Cardinal; out Pos: Cardinal; StartPos: Cardinal = 0;
  UsingMask: Boolean = False): Boolean;
function CheckMatch(Key, Val: PAnsiChar; UsingMask: Boolean = False): Boolean;
begin
  if not UsingMask then
    Result := Key^ = Val^ else
  begin
    case Byte(Key^) of
    Byte(AnsiChar('?')):
      Result := ((Val^ >= AnsiChar('a')) and (Val^ <= AnsiChar('z'))) or
                ((Val^ >= AnsiChar('A')) and (Val^ <= AnsiChar('Z')));
    Byte(AnsiChar('#')):
      Result := (Val^ >= AnsiChar('0')) and (Val^ <= AnsiChar('9'));
    else
      Result := Key^ = Val^;
    end;
  end;
end;
var
  idx, idy, iMatchCount: Cardinal;
begin
  Result := False;
  if (not Assigned(Key)) or (not Assigned(Buffer)) or (KeyLen <= 0) or
    (BufferLen <= 0) or (KeyLen > BufferLen) or (StartPos >= BufferLen) then
    Exit;

  for idx := StartPos to BufferLen - KeyLen do
  begin
    if not CheckMatch(Key, Buffer + idx, UsingMask) then Continue else
    begin
      iMatchCount := 1;
      if KeyLen = iMatchCount then Break;
      
      for idy := 1 to KeyLen - 1 do
        if not CheckMatch(Key + idy, Buffer + idx + idy, UsingMask) then Break else
        begin
          Inc(iMatchCount);
        end;

      if iMatchCount = KeyLen then Break;
    end;
  end;

  if iMatchCount = KeyLen then
  begin
    Result := True;
    Pos := idx;
  end else
  begin
    Result := False;
    Pos := BufferLen + 1;
  end;
end;

{*
  ByteSearch WideString version;
*}
function ByteSearchW(Key, Buffer: PWideChar;
  KeyLen, BufferLen: Cardinal; out Pos: Cardinal; StartPos: Cardinal = 0;
  UsingMask: Boolean = False): Boolean;
function CheckMatch(Key, Val: PWideChar; UsingMask: Boolean = False): Boolean;
begin
  if not UsingMask then
    Result := Key^ = Val^ else
  begin
    case Byte(Key^) of
    Byte(WideChar('?')):
      Result := ((Val^ >= WideChar('a')) and (Val^ <= WideChar('z'))) or
                ((Val^ >= WideChar('A')) and (Val^ <= WideChar('Z')));
    Byte(WideChar('#')):
      Result := (Val^ >= WideChar('0')) and (Val^ <= WideChar('9'));
    else
      Result := Key^ = Val^;
    end;
  end;
end;
var
  idx, idy, iMatchCount: Cardinal;
begin
  Result := False;
  if (not Assigned(Key)) or (not Assigned(Buffer)) or (KeyLen <= 0) or
    (BufferLen <= 0) or (KeyLen > BufferLen) or (StartPos >= BufferLen) then
    Exit;

  for idx := StartPos to BufferLen - KeyLen do
  begin
    if not CheckMatch(Key, Buffer + idx, UsingMask) then Continue else
    begin
      iMatchCount := 1;
      if KeyLen = iMatchCount then Break;
      
      for idy := 1 to KeyLen - 1 do
        if not CheckMatch(Key + idy, Buffer + idx + idy, UsingMask) then Break else
        begin
          Inc(iMatchCount);
        end;

      if iMatchCount = KeyLen then Break;
    end;
  end;

  if iMatchCount = KeyLen then
  begin
    Result := True;
    Pos := idx;
  end else
  begin
    Result := False;
    Pos := BufferLen + 1;
  end;
end;

procedure TfrmMain.btnGetWindowClick(Sender: TObject);
var
  pcCaption, pcClass: PAnsiChar;
begin
  pcCaption := nil;
  pcClass := nil;
  if '' <> Trim(lbledtWindowCaption.Text) then
    pcCaption := PAnsiChar(lbledtWindowCaption.Text);
  if '' <> Trim(lbledtWindowClass.Text) then
    pcClass := PAnsiChar(lbledtWindowClass.Text);
  if (nil = pcCaption) and (nil = pcClass) then Exit;

  mmoLog.Clear;
  
  FWnd := FindWindow(pcClass, pcCaption);
  mmoLog.Lines.Add(Format('Window Handle: %x', [FWnd]));   
  mmoLog.Lines.Add('==============================');

  if not IsWindow(FWnd) then Exit;

  FThread := GetWindowThreadProcessId(FWnd, FProcess);
  mmoLog.Lines.Add(Format('ProcessId: %x', [FProcess]));
  mmoLog.Lines.Add(Format('ThreadId: %x', [FThread]));
  mmoLog.Lines.Add('==============================');

  if 0 = FProcess then Exit;

  FProcessHandle := OpenProcess(PROCESS_VM_READ, False, FProcess);
  mmoLog.Lines.Add(Format('ProcessHandle: %x', [FProcessHandle]));  
  mmoLog.Lines.Add('==============================');

  if 0 = FProcessHandle then Exit;
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
  if FProcessHandle > 0 then CloseHandle(FProcessHandle);
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  FAnsiString := '999999999';
  FWideString := '777777777';
  FWideSerial := 'R333-P222-Q333-W888';
  mmoLog.Clear;
  FProcessHandle := 0;
  if EnabledDebugPrivilege(True) then
    mmoLog.Lines.Add('Debug privilege succeed!');
end;

procedure TfrmMain.appEvsIdle(Sender: TObject; var Done: Boolean);
begin
  btnSearch.Enabled := FProcessHandle > 0;
end;

procedure TfrmMain.btnSearchClick(Sender: TObject);
const
  BufferLen = $400;
//  BaseAddr = $1CC4F0;
  BaseAddr = $40000;
var
  aKey: AnsiString;
  wKey: WideString;
  pBaseAddr, pBuffer, pDestStr: Pointer;
  iReadSize, idx, iDummy: Cardinal;
  bRT: LongBool;
  wcChar: WideChar;
  wsStr: WideString;
begin
  aKey := Trim(lbledtSearchString.Text);
  wKey := aKey;
  if aKey = '' then Exit;

  pBuffer := GetMemory(BufferLen);
  pBaseAddr := Pointer(BaseAddr);
  while Integer(pBaseAddr) < $800000 do
  begin
    bRT := ReadProcessMemory(FProcessHandle, pBaseAddr, pBuffer,
                             BufferLen, iReadSize);
    if not bRT then
      mmoLog.Lines.Add(Format('Read Memmory Error :%x', [GetLastError]));

    if (not bRT) or (0 = iReadSize) then
    begin
      pBaseAddr := Pointer(Integer(pBaseAddr) + BufferLen);
      Continue;
    end;
      
    idx := 0;
    if chkIsUnicode.Checked then // WideString
    begin
      while idx < iReadSize div 2 do
      begin
        bRT := ByteSearchW(PWideChar(@wKey[1]), PWideChar(pBuffer),
                           Length(wKey), iReadSize div SizeOf(WideChar),
                           idx, idx, chkIsMask.Checked);
        if bRT then
        begin
          pDestStr := GetMemory(Length(wKey) * 2);
          ReadProcessMemory(FProcessHandle,
            Pointer(Integer(pBaseAddr) + idx * 2), pDestStr, Length(wKey) * 2, iDummy);
          mmoLog.Lines.Add(
            Format('Found key string [%s] AT Address %x',
              [Copy(WideString(pDestStr), 1, Length(wKey)), Integer(pBaseAddr) + idx * 2]));
          FreeMemory(pDestStr);
          Inc(idx);
        end;

        Application.ProcessMessages;
      end;
      pBaseAddr := Pointer(Integer(pBaseAddr) + iReadSize - Length(wKey) * SizeOf(WideChar));
    end else        // AnsiString
    begin
      while idx < iReadSize do
      begin
        bRT := ByteSearchA(PAnsiChar(@aKey[1]), pBuffer, Length(aKey), BufferLen,
                         idx, idx, chkIsMask.Checked);
        if bRT then
        begin
          pDestStr := GetMemory(Length(aKey) + 1);
          ReadProcessMemory(FProcessHandle,
            Pointer(Integer(pBaseAddr) + idx), pDestStr, Length(aKey), iDummy);
          mmoLog.Lines.Add(
            Format('Found key string [%s] AT Address %x',
              [Copy(AnsiString(pDestStr), 1, Length(aKey)), Integer(pBaseAddr) + idx]));
          FreeMemory(pDestStr);
          Inc(idx);
        end;

        Application.ProcessMessages;
      end;
      pBaseAddr := Pointer(Integer(pBaseAddr) + iReadSize - Length(aKey));
    end;


  end;
  FreeMemory(pBuffer);
end;

end.
